home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / list-functions.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  4KB  |  114 lines
  1.  
  2. (in-package :pcl)
  3.  
  4. (defvar *defun-list* nil)
  5. (defvar *defmethod-list* nil)
  6. (defvar *defmacro-list* nil)
  7. (defvar *defgeneric-list* nil)
  8. (defvar *proclaim-list* nil)
  9.  
  10. (defun list-functions (&optional print-p)
  11.   (let ((eof '(eof))
  12.     (*package* *package*))
  13.     (setq *defun-list* nil
  14.       *defmethod-list* nil
  15.       *defmacro-list* nil
  16.           *proclaim-list* nil)
  17.     (labels ((process-form (form)
  18.            (when (consp form)
  19.          (case (car form)
  20.            ((in-package export import shadow shadowing-import) (eval form))
  21.            #+lcl3.0 (lcl:handler-bind (eval form))
  22.            (let (when print-p (print form)))
  23.                    (declaim
  24.                      (if (eq (caadr form) 'ftype)
  25.                          (setf *proclaim-list*
  26.                                (append (cdr form) *proclaim-list*))
  27.                          (when print-p (print form))))
  28.            (defun (push (list (cadr form) (caddr form))
  29.                 *defun-list*))
  30.            (defmethod (push (list (cadr form) (caddr form)) 
  31.                     *defmethod-list*))
  32.            (defmacro (push (list (cadr form) (caddr form)) 
  33.                    *defmacro-list*))
  34.            (defgeneric (push (list (cadr form) (caddr form)) 
  35.                      *defgeneric-list*))
  36.            (eval-when (mapc #'process-form (cddr form)))
  37.            (progn (mapc #'process-form (cdr form)))
  38.            ((defvar defparameter defconstant proclaim 
  39.              defsetf defstruct deftype define-compiler-macro))
  40.            ((define-walker-template defopcode defoperand 
  41.              define-method-combination define-constructor-code-type 
  42.              defclass))
  43.            (t (when print-p (print form)))))))
  44.       (dolist (file (system-source-files 'pcl))
  45.     (with-open-file (in file :direction :input)
  46.       (loop (let ((form (read in nil eof)))
  47.           (when (eq form eof) (return nil))
  48.           (process-form form))))))
  49.     (values (length *defun-list*)
  50.         (length *defmethod-list*)
  51.         (length *defmacro-list*)
  52.         (length *defgeneric-list*))))
  53.  
  54. (defun list-all-gfs (&optional all-p)
  55.   (let ((keys nil) (opt nil)
  56.     (gf-vector (make-array 10 :initial-element nil))
  57.     (*package* *the-pcl-package*)
  58.     (*print-pretty* nil)
  59.     (s-a-n (find-package "SLOT-ACCESSOR-NAME"))
  60.     (lisp-sans (list (slot-reader-symbol 'function)
  61.                          (slot-reader-symbol 'type))))
  62.     (map-all-generic-functions 
  63.      #'(lambda (gf)
  64.      (when (or all-p
  65.            (let ((name (generic-function-name gf)))
  66.              (when (consp name) (setq name (cadr name)))
  67.              (and (not (find #\: (symbol-name name)))
  68.               (or (eq (symbol-package name) *the-pcl-package*)
  69.                   (memq name lisp-sans)
  70.                   (and (eq (symbol-package name) s-a-n)
  71.                    (string= "PCL " (symbol-name name) :end2 4))))))
  72.        (let ((ll (generic-function-lambda-list gf)))
  73.          (multiple-value-bind (nrequired noptional 
  74.                          keysp restp allow-other-keys-p keywords)
  75.          (analyze-lambda-list ll)
  76.            (if (or keysp restp allow-other-keys-p keywords)
  77.            (push gf keys)
  78.            (if (plusp noptional)
  79.                (push gf opt)
  80.                (push gf (aref gf-vector nrequired)))))))))
  81.     (with-open-file (out (let* ((system (get-system 'pcl))
  82.                 (*system-directory* (funcall (car system))))
  83.                (make-pathname :defaults
  84.                       (truename (make-source-pathname "defsys"))
  85.                       :name "generic-functions"))
  86.              :direction :output)
  87.       (format out ";;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-~2%")
  88.       (format out "(in-package :pcl)~%")
  89.       (flet ((print-gf-list (list)
  90.            (setq list
  91.              (sort (mapcar #'generic-function-name list)
  92.                #'(lambda (sym1 sym2)
  93.                    (let* ((s1 (if (consp sym1) (cadr sym1) sym1))
  94.                       (s2 (if (consp sym2) (cadr sym2) sym2))
  95.                       (p1 (symbol-package s1))
  96.                       (p2 (symbol-package s2)))
  97.                  (if (eq p1 p2)
  98.                      (string< (symbol-name s1) (symbol-name s2))
  99.                      (string< (package-name p1) (package-name p2)))))))
  100.            (dolist (sym list)
  101.          (let ((*print-case* :downcase))
  102.            (format out "~&~S~%"
  103.                `(defgeneric ,sym ,(generic-function-lambda-list
  104.                            (gdefinition sym))))))))
  105.     (dotimes (i 10)
  106.       (when (aref gf-vector i)
  107.         (format out "~%;;; ~D arguments ~%" i)
  108.         (print-gf-list (aref gf-vector i))))
  109.     (format out "~%;;; optional arguments  ~%")
  110.     (print-gf-list opt)
  111.     (format out "~%;;; keyword arguments  ~%")
  112.     (print-gf-list keys))
  113.       (terpri out))))
  114.